home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 3: CDPD 3 / Almathera Ten on Ten - Disc 3: CDPD3.iso / fish / 001-100 / 001-025 / 018 / xlisp1.6 / xlsys.c < prev    next >
C/C++ Source or Header  |  1995-03-17  |  3KB  |  249 lines
  1. /* xlsys.c - xlisp builtin system functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE ***xlstack,*xlenv;
  10. extern int anodes;
  11.  
  12. /* external symbols */
  13. extern NODE *a_subr,*a_fsubr;
  14. extern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr,*a_vect;
  15. extern NODE *true;
  16.  
  17. /* xload - direct input from a file */
  18. NODE *xload(args)
  19.   NODE *args;
  20. {
  21.     NODE ***oldstk,*fname,*val;
  22.     int vflag,pflag;
  23.     char *name;
  24.  
  25.     /* create a new stack frame */
  26.     oldstk = xlsave(&fname,NULL);
  27.  
  28.     /* get the file name, verbose flag and print flag */
  29.     fname = xlarg(&args);
  30.     vflag = (args ? xlarg(&args) != NIL : TRUE);
  31.     pflag = (args ? xlarg(&args) != NIL : FALSE);
  32.     xllastarg(args);
  33.  
  34.     /* get the filename string */
  35.     if (symbolp(fname))
  36.     name = getstring(getpname(fname));
  37.     else if (stringp(fname))
  38.     name = getstring(fname);
  39.     else
  40.     xlfail("bad argument type",fname);
  41.  
  42.     /* load the file */
  43.     val = (xlload(name,vflag,pflag) ? true : NIL);
  44.  
  45.     /* restore the previous stack frame */
  46.     xlstack = oldstk;
  47.  
  48.     /* return the status */
  49.     return (val);
  50. }
  51.  
  52. /* xgc - xlisp function to force garbage collection */
  53. NODE *xgc(args)
  54.   NODE *args;
  55. {
  56.     /* make sure there aren't any arguments */
  57.     xllastarg(args);
  58.  
  59.     /* garbage collect */
  60.     gc();
  61.  
  62.     /* return nil */
  63.     return (NIL);
  64. }
  65.  
  66. /* xexpand - xlisp function to force memory expansion */
  67. NODE *xexpand(args)
  68.   NODE *args;
  69. {
  70.     int n,i;
  71.  
  72.     /* get the new number to allocate */
  73.     n = (args ? getfixnum(xlmatch(INT,&args)) : 1);
  74.     xllastarg(args);
  75.  
  76.     /* allocate more segments */
  77.     for (i = 0; i < n; i++)
  78.     if (!addseg())
  79.         break;
  80.  
  81.     /* return the number of segments added */
  82.     return (cvfixnum((FIXNUM)i));
  83. }
  84.  
  85. /* xalloc - xlisp function to set the number of nodes to allocate */
  86. NODE *xalloc(args)
  87.   NODE *args;
  88. {
  89.     int n,oldn;
  90.  
  91.     /* get the new number to allocate */
  92.     n = getfixnum(xlmatch(INT,&args));
  93.  
  94.     /* make sure there aren't any more arguments */
  95.     xllastarg(args);
  96.  
  97.     /* set the new number of nodes to allocate */
  98.     oldn = anodes;
  99.     anodes = n;
  100.  
  101.     /* return the old number */
  102.     return (cvfixnum((FIXNUM)oldn));
  103. }
  104.  
  105. /* xmem - xlisp function to print memory statistics */
  106. NODE *xmem(args)
  107.   NODE *args;
  108. {
  109.     /* make sure there aren't any arguments */
  110.     xllastarg(args);
  111.  
  112.     /* print the statistics */
  113.     stats();
  114.  
  115.     /* return nil */
  116.     return (NIL);
  117. }
  118.  
  119. /* xtype - return type of a thing */
  120. NODE *xtype(args)
  121.     NODE *args;
  122. {
  123.     NODE *arg;
  124.  
  125.     if (!(arg = xlarg(&args)))
  126.     return (NIL);
  127.  
  128.     switch (ntype(arg)) {
  129.     case SUBR:    return (a_subr);
  130.     case FSUBR:    return (a_fsubr);
  131.     case LIST:    return (a_list);
  132.     case SYM:    return (a_sym);
  133.     case INT:    return (a_int);
  134.     case FLOAT:    return (a_float);
  135.     case STR:    return (a_str);
  136.     case OBJ:    return (a_obj);
  137.     case FPTR:    return (a_fptr);
  138.     case VECT:    return (a_vect);
  139.     default:    xlfail("bad node type");
  140.     }
  141. }
  142.  
  143. /* xbaktrace - print the trace back stack */
  144. NODE *xbaktrace(args)
  145.   NODE *args;
  146. {
  147.     int n;
  148.  
  149.     n = (args ? getfixnum(xlmatch(INT,&args)) : -1);
  150.     xllastarg(args);
  151.     xlbaktrace(n);
  152.     return (NIL);
  153. }
  154.  
  155. /* xexit - get out of xlisp */
  156. NODE *xexit(args)
  157.   NODE *args;
  158. {
  159.     xllastarg(args);
  160.     osfinish ();
  161.     exit();
  162. }
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  
  220.  
  221.  
  222.  
  223.  
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  
  247.  
  248.  
  249.